home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / printr3.arc / PRINTR2.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-28  |  22KB  |  652 lines
  1.  
  2. {$S-,V-}
  3. (****************************************************************************)
  4. (*                                                                          *)
  5. (*                             Mesa Software                                *)
  6. (*                       3302 Fourth Ave, Suite 101                         *)
  7. (*                          San Diego, Ca. 92103                            *)
  8. (*                                                                          *)
  9. (*                                                                          *)
  10. (*       Program :    Unit Printr2         File Name :  printr2.pas         *)
  11. (*                                                                          *)
  12. (*       Release :    Version 1.0               Date :  Dec. 15, 1989       *)
  13. (*                                                                          *)
  14. (*                                                                          *)
  15. (****************************************************************************)
  16.  
  17.     Unit printr2;
  18.     Interface
  19.  
  20.      {Requires TJocks5.
  21.       Use at your own risk. Mesa Software assumes no
  22.       liability for the use of this software}
  23.  
  24.     uses CRT,dos,fastttt5,miscttt5,winttt5,strnttt5,keyttt5;
  25.  
  26.       Const
  27.         esc            = #27;
  28.         off            = #0;
  29.         NLQ            = (esc + '!' + #1);
  30.         NLQ_OFF        = (esc + '!' + #0);
  31.         Supercrpt      = (esc + 'S' + #0);
  32.         Subscrpt       = (esc + 'S' + #1);
  33.         scrp_off       = (esc + 'T');
  34.         Comprsd        = (esc + #15);
  35.         uncomprsd      = (esc + #18);
  36.         Emphaszd       = (esc + 'E');
  37.         unemphszd      = (esc + 'F');
  38.         Dbl_prtng      = (esc + 'G');
  39.         un_dbl         = (esc + 'H');
  40.  
  41.         dbl_wid        = (esc + 'W' + #1);
  42.         un_wid         = (esc + 'W' + off);
  43.  
  44.         {The two print commands below are the same as the two
  45.          above.}
  46.         expanded       = esc + '!' + #48;
  47.         unexpand       = esc +  'W' + off;
  48.  
  49.  
  50.         undr_lin       = (esc + '-' + #1);
  51.         undr_lin_off   = (esc + '-' + off);
  52.         backspc        = (#8);
  53.         char_byte      = '$';
  54.           {This is the char you see in the banner and
  55.            report headers.  Try !,*,#, or %.  Taylor
  56.            your chars for different reports}
  57.  
  58.         thirteen       = 13;
  59.         backspace      = #8;
  60.         centered       = #27 + 'a' + #1;
  61.         left_margin    = #27 + 'a' + off;
  62.         line_feed      = #10;
  63.         form_feed      = #12;
  64.         carig_rtn      = #13;
  65.         author         = 'Tom Devanney';
  66.  
  67.      Type
  68.        Datestr = string[8];
  69.  
  70.      var
  71.       lst                  : Text;
  72.       page                 : string;
  73.       num                  : integer;
  74.  
  75.       Function  Printer_on : Boolean;
  76.       Procedure Beepr;
  77.       Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);
  78.       Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);
  79.       Function  IO_Not_OK(num : word) : Boolean;
  80.       Function  GetSystemDate : Datestr;
  81.       Function  NumToStr(number : LongInt) : string;
  82.       Procedure Check_color(var Textf,Back : byte);
  83.  
  84.     {======================================================================}
  85.  
  86.     Implementation
  87.  
  88.     {======================================================================}
  89.  
  90.  
  91.     Procedure Check_color(var Textf,Back : byte);
  92.  
  93.        {This is to change any color combo into white on black for monochrome
  94.           screens}
  95.  
  96.        begin
  97.          if (baseOfScreen <> $B800) then
  98.          begin
  99.            Textf := 15;
  100.            Back  := 0;
  101.          end;
  102.        end;
  103.  
  104.      Function GetSystemDate : Datestr;   {string[10]}
  105.  
  106.      {This is to get a system date from the system and return as a string}
  107.  
  108.        Var
  109.          regs         :  Registers;
  110.          st2,st3,st4  : String[10];
  111.  
  112.          begin
  113.            Fillchar(regs,Sizeof(regs),0);
  114.            Regs.AH := $2A;     {Interrupt for system date}
  115.            MsDos(regs);
  116.            With regs do
  117.            Begin
  118.              Str(CX, st2); {year}
  119.              Str(DH, st3); {Month}
  120.              Str(DL, st4); {Day}
  121.            end;
  122.            If length(st3) = 1 then  st3 := '0' + st3;
  123.            If length(st4) = 1 then  st4 := '0' + st4;
  124.            getsystemdate := st3 + '/' +  st4 + '/' + copy(st2,3,2);
  125.          end;
  126.  
  127.  
  128.     Function NumToStr(number : LongInt) : string;
  129.  
  130.     {-Convert a longinteger,word,integer,byte to a string}
  131.  
  132.       var
  133.         numstr : string;
  134.       begin
  135.         Str(number,numstr);
  136.         NumToStr := numstr;
  137.       end;
  138.  
  139.  
  140.     Procedure Beepr;
  141.  
  142.       {This is a fancy lawyer telephone beeper sound
  143.        The sound you hear is money}
  144.  
  145.       Const
  146.         itration = 3;
  147.       var
  148.         countr   : integer;
  149.  
  150.       begin
  151.         for countr := 1 to itration do
  152.         begin
  153.           Sound(949); {925..999}
  154.           Delay(50);
  155.           sound(499); {450..600}
  156.           delay(50);
  157.         end;
  158.         Nosound;
  159.       end; { Beep }
  160.  
  161.     Function Printer_on : Boolean;
  162.  
  163.       {This is a printer screen that is easy to use}
  164.  
  165.       var
  166.         line,col,end_lin,
  167.         end_col,box_knd    : integer;
  168.         Regs               : registers;
  169.         answr              : char;
  170.         message            : string;
  171.         textf,boxf,back    : byte;
  172.  
  173.       begin
  174.         answr := ' ';
  175.         clrscr;
  176.         col     := 10;
  177.         line    := 10;
  178.         end_col := 70;
  179.         end_lin := 20;
  180.         box_knd := 0;  {0..4,5..9 choose another box type to suit your style}
  181.        Printer_on := False;
  182.        savescreen(1);
  183.        boxf  := white;
  184.        back  := lightgray;
  185.        check_color(boxf,back);
  186.        Fbox(col,line,end_col,end_lin,boxf,back,box_knd);
  187.        boxf  := yellow;
  188.        back  := red;
  189.        check_color(boxf,back);
  190.        Fbox(col + 1 ,line + 1,end_col - 1,end_lin - 1,boxf,back,box_knd);
  191.        back := black;
  192.        check_color(boxf,back);
  193.        Fbox(col + 2,line + 2,end_col - 2,end_lin - 2,boxf,back,box_knd);
  194.        textf := yellow;
  195.        check_color(textf,back);
  196.        Writebetween(col,end_col,line + (end_lin - line) div 2 - 1,textf,back,'CHECK THE PRINTER FOR PAPER');
  197.        message := 'THE PRINTER IS READY, HIT RETURN TO START';
  198.  
  199.        Offcursor;
  200.        with regs do
  201.        begin
  202.          ah := 2;
  203.          dx := 0;
  204.          intr($17,regs);
  205.          printer_on := (ah = 144);
  206.        end;
  207.        Repeat
  208.          if (regs.ah <> 144)  then
  209.            message := 'PRINTER OFF LINE, ESC TO ABORT OR RETURN TO CONTINUE';
  210.            beepr;
  211.            Writebetween(col,end_col,line + (end_lin - line) div 2 + 1,textf,back, message);
  212.            answr := getkey;
  213.          with regs do
  214.          begin
  215.            ah := 2;
  216.            dx := 0;
  217.            intr($17,regs);
  218.            printer_on := (ah = 144);
  219.          end;
  220.        until ((regs.ah = 144) or (answr = #27));
  221.        if (answr = #27) then
  222.          Printer_on := False;
  223.        restorescreen(1);
  224.        disposescreen(1);
  225.     end; {Function  Printer_on_line}
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.    Function IO_NOT_OK(num : word) : Boolean;
  234.  
  235.      {This is an error manager that will enable you to escape most runtime
  236.        errors.  In some cases you will add recovery code after this routine
  237.        to your program}
  238.  
  239.      var
  240.        msg,Drive_a,
  241.        Drive_b : string;
  242.  
  243.      begin
  244.        Drive_a := 'A:';
  245.        Drive_b := 'B:';
  246.        Flushkeybuffer;
  247.        msg := '';
  248.        IO_Not_ok := (num <> 0);
  249.        if (num <> 0) then
  250.        begin
  251.          case num of
  252.            002 : msg := 'File not found';
  253.            003 : msg := 'Path not found';
  254.            004 : msg := 'Too many open files, Check Files = in config.sys';
  255.            005 : msg := 'File access denied or Drive/Directory exists';
  256.            006 : msg := 'Invalid file handle';
  257.            012 : msg := 'Invalid file access code';
  258.            015 : msg := 'Invalid drive number';
  259.            016 : msg := 'Cannot remove current directory';
  260.            017 : msg := 'Cannot rename across drives';
  261.            100 : msg := 'Disk read error, is file open ?';
  262.            101 : msg := 'Disk write error, is disk full ?';
  263.            102 : msg := 'File not assigned, File name not assigned?';
  264.            103 : msg := 'File not open';
  265.            104 : msg := 'File not open for input';
  266.            105 : msg := 'File not open for output';
  267.            106 : msg := 'Invalid numeric format';
  268.            150 : msg := 'Disk is write-protected, Remove tab?';
  269.            151 : msg := 'Unknown unit';
  270.            152 : msg := 'Drive not ready, close drive door, Thank you';
  271.            153 : msg := 'Unknown command';
  272.            154 : msg := 'CRC error in data';
  273.            155 : msg := 'Bad drive request structure length';
  274.            156 : msg := 'Disk seek error';
  275.            {I use error 157 to sense an unformatted floppy.}
  276.            157 : msg := 'Unknown media type. We will format Floppy.';
  277.            158 : msg := 'Sector not found';
  278.            159 : msg := 'Printer out of paper, so put some in';
  279.            160 : msg := 'Device write fault. Usually printer is off';
  280.            161 : msg := 'Device read fault';
  281.            162 : msg := 'Hardware failure';
  282.            200 : msg := 'Division by zero';
  283.            201 : msg := 'Range check error';
  284.            202 : msg := 'Stack overflow';
  285.            203 : msg := 'Insufficient memory';
  286.            204 : msg := 'Invalid pointer operation';
  287.            205 : msg := 'Floating point overflow, number too big';
  288.            206 : msg := 'Floating point underflow';
  289.            207 : msg := 'Invalid floating point operation';
  290.            208 : msg := 'Overlay manager not installed';
  291.            209 : msg := 'Overlay file read error';
  292.          else
  293.            msg := 'Turbo runtime error '+ NumToStr(num);
  294.       end;
  295.        savescreen(5);
  296.        {These colors are for ega/vga, monochrome is not supported
  297.          Here is a hint for good window/message formatting.
  298.           Choose an odd number of lines for the window and
  299.                  an odd number of messages to display
  300.           or     an even number of lines for the window and
  301.                  an even number of messages to display.
  302.          Display your message centered in the window or box and the
  303.          screen will look superb.  Makes happy satisfied users}
  304.  
  305.        Mkwin(10,8,70,17,yellow, lightgray,4);
  306.        Writebetween(11,69,13,black,lightgray,upper(msg));
  307.        Writebetween(11,69,14,black,lightgray,'HIT RETURN TO CONTINUE');
  308.        readln;
  309.        restorescreen(5);
  310.        disposescreen(5);
  311.        if ((num = 157) or (num = 3)) then
  312.          begin
  313.            clrscr;
  314.            SwapVectors;
  315.            Exec(GetEnv('COMSPEC'), '/C Format ' + Drive_a);
  316.            SwapVectors;
  317.            if DosError <> 0 then
  318.              begin
  319.                Writebetween(11,69,13,black,lightgray,upper('Could not execute COMMAND.COM'));
  320.                Readln;
  321.              end
  322.            else
  323.              begin
  324.                Writebetween(11,69,13,black,lightgray,upper('Disk ' + Drive_a + ' is Formatted'));
  325.                Readln;
  326.              end;
  327.          end;
  328.      end;
  329.    end;
  330.  
  331.  
  332. (**************************************************************************)
  333. (*                                                                        *)
  334. (*                                                                        *)
  335. (*                            Mesa Software                               *)
  336. (*                       3302 Fourth Ave, Suite 101                       *)
  337. (*                          San Diego, Ca. 92103                          *)
  338. (*                                                                        *)
  339. (*                                                                        *)
  340. (*       Procedure :   Banner            File Name : Printr2.pas          *)
  341. (*                                                                        *)
  342. (*       Release   :   Version 1.0            Date : Dec 15, 1989         *)
  343. (*                                                                        *)
  344. (*                                                                        *)
  345. (*                                                                        *)
  346. (**************************************************************************)
  347.  
  348.  
  349.    Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);
  350.  
  351.    (*  this is a procedure with the following call:
  352.        banner(co_nam,addrs,City,st,zip,rpt_title);
  353.  
  354.           co_nam    := 'MESA SOFTWARE';
  355.           addrs     := '3302 FOURTH AVENUE, SUITE 101';
  356.           city      := 'SAN DIEGO'; {If necessary,A routine will add the comma}
  357.           st        := 'CALIFORNIA';
  358.           zip       := '92103';
  359.           phone     := '1(555)555-5555';
  360.           rpt_title := 'ACCOUNTS RECEIVABLE AGING REPORT';
  361.           dte       := Date; this date routine is in Technojocks.miscttt unit.
  362.  
  363.        We have Tested it using a Panasonic 1592. The routine is flexible enough to
  364.        take most any size strings within reason. Watch the report titles as they
  365.        are expanded, centered and added to. Check the code for comma addition.
  366.  
  367.     *)
  368.  
  369.    var
  370.      i,j,k,pag_lnth,
  371.      lin_lnth,lin_counter,char_count,
  372.      Top_headr,bottom_headr,title_lines      : integer;
  373.      page                                    : string;
  374.  
  375.  
  376.  
  377.    Procedure Banner_Top;
  378.  
  379.       var
  380.         countr,i : integer;
  381.  
  382.       begin
  383.         for countr := 1 to top_headr do
  384.         begin
  385.           for i := 1 to lin_lnth do
  386.             write(lst,char_byte);
  387.           Writeln(lst);
  388.           char_count := 0;
  389.           inc(lin_counter);
  390.         end;
  391.       end;
  392.  
  393.     Procedure Banner_Bottom;
  394.  
  395.       var
  396.         countr,i : integer;
  397.  
  398.       begin
  399.         for countr := 1 to bottom_headr do
  400.         begin
  401.           for i := 1 to lin_lnth - 1  do
  402.             write(lst,char_byte);
  403.           Writeln(lst,char_byte);
  404.         end;
  405.           for countr := 1 to 5 do
  406.           writeln(lst);
  407.           {After this routine, the form length, etc, should be set
  408.               for your report paging to follow}
  409.       end;
  410.  
  411.  
  412.      Procedure Banner_left;
  413.  
  414.        begin
  415.  
  416.          {You can use most any replicating code to write the
  417.           following. The sample below will give you an option for most
  418.           of banner routines. You probably know the argument. My code is
  419.           perfect, yours is not so perfect. So Help Yourself.
  420.           You must be careful with the TJocks.Fastttt5.Replicate Function.
  421.           There is a LIMIT of 80 characters. The function is primarily for
  422.           screen writes, so be careful in using it for printer lengths over
  423.           80 characters, it returns a value of 1.}
  424.  
  425.          write(lst,#27 + 'a' + #0);
  426.          write(lst,replicate(10,char_byte));
  427.          write(lst,#27 + 'j' + #0);
  428.        end;
  429.  
  430.      Procedure Banner_right;
  431.  
  432.         begin
  433.           write(lst,#27 + 'a' + #2);
  434.           write(lst,#27 + 'Q' + #132);
  435.           writeln(lst,replicate(10,char_byte));
  436.         end;
  437.  
  438.       Procedure Filler_Line;
  439.  
  440.         begin
  441.           Banner_Left;
  442.           Banner_Right;
  443.         end;
  444.  
  445.  
  446.       Procedure Filler(num : integer);
  447.  
  448.         var
  449.           countr      : integer;
  450.  
  451.         begin
  452.           for countr := 1 to num do
  453.             begin
  454.               Filler_Line;
  455.             end;
  456.           end;
  457.  
  458.      Procedure Names;
  459.  
  460.         begin
  461.           if copy(city,length(city),1) <> ',' then    {We add a comma if necessary}
  462.             city := city + ', ' +  st + '  ' + zip
  463.           else
  464.             city := city + ' ' + st + '  ' + zip;
  465.          end;
  466.  
  467.      Procedure Report_Title(str1 : string);
  468.  
  469.        begin
  470.          banner_left;
  471.          write(lst,#27 + 'a' + #1); {Auto Centering}
  472.          write(lst,#27 + '!' + #48); {Double width/double strike printing}
  473.          write(lst,str1);
  474.          write(lst,#27 + 'W' + #0);
  475.          write(lst,#27 + 'H');
  476.          write(lst,#27 + '!' + #0);
  477.          write(lst,#27 + 'j' + #0);
  478.          banner_right;
  479.        end;
  480.  
  481.  
  482.      Procedure Title(sub_title : string);
  483.  
  484.        begin
  485.          Banner_left;
  486.          write(lst,#27 + 'a' + #1);
  487.          write(lst,upper(sub_title));
  488.          write(lst,#27 + 'j' + #0);
  489.          Banner_Right;
  490.        end;
  491.  
  492.       begin
  493.         write(lst,#27,'@');     {Initializes the printer}
  494.         write(lst,#27+'C'+#62); {Sets the page length to 62 lines}
  495.         top_headr    := 6;      {This is the top lines to fill}
  496.         pag_lnth     := 60;     {This is the page length  50..66}
  497.         Bottom_headr := 6;      {Same as top_headr}
  498.         lin_lnth     := 132;    {This was written using wide carriage. Try 80}
  499.         lin_counter  := 1;
  500.         title_lines  := 5;      {We need this to calculate top and bottom filler space}
  501.         char_count   := 0;
  502.         Names;
  503.         banner_top;
  504.         num := ((pag_lnth  - 20) div 2 - 1);
  505.         Filler(num);
  506.         rpt_title := upper(rpt_title);
  507.         report_title(rpt_title);
  508.         num := 2;
  509.         Filler(num);
  510.         title(date);
  511.         num := 11;
  512.         Filler(num);
  513.         title(co_nam);
  514.         title(addrs);
  515.         title(city);
  516.         title(phone);
  517.         num := 12;
  518.         Filler(num);
  519.         Banner_bottom;
  520.      end;
  521.  
  522.  
  523. (***************************************************************************)
  524. (*                                                                         *)
  525. (*                            Mesa Software                                *)
  526. (*                       3302 Fourth Ave, Suite 101                        *)
  527. (*                          San Diego, Ca. 92103                           *)
  528. (*                                                                         *)
  529. (*                                                                         *)
  530. (*     Procedure :    Report-hdr;          File Name :  PRINTR2.PAS        *)
  531. (*                                                                         *)
  532. (*       Release :    Version 1.0               Date :  Dec 15,1989        *)
  533. (*                                                                         *)
  534. (*                                                                         *)
  535. (*                                                                         *)
  536. (***************************************************************************)
  537.  
  538.     Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);
  539.  
  540.  
  541.  
  542.      (*  This is a procedure with the following call:
  543.        Report_Hdr(Rpt_Title,co_nam,addrs,City,st,zip,rpt_title,page);
  544.  
  545.           co_nam    := 'MESA SOFTWARE';
  546.           addrs     := '3302 FOURTH AVENUE, SUITE 101';
  547.           city      := 'SAN DIEGO';
  548.           st        := 'CALIFORNIA';
  549.           zip       := '92103';
  550.           phone     := '1(555)555-5555';
  551.           dte       := Date; this date routine is in Technojocks, sub your own
  552.           Rpt_Title := 'ACCOUNTS RECEIVABLE AGING REPORT';
  553.  
  554.         The code here is different from Banner. Choose your own style.
  555.                                                             *)
  556.       var
  557.        i,j,k,lnth,pag_num : integer;
  558.        pag                : string;
  559.  
  560.  
  561.      Procedure Title(rpt_title : string);
  562.  
  563.        var i : integer;
  564.        begin
  565.          for i := 1 to (lnth div 2)  do write(lst,' ');
  566.          j := i;
  567.          write(lst,expanded);
  568.          write(lst,Emphaszd);
  569.          i := length(rpt_title);
  570.          if odd(i) then rpt_title := rpt_title + ' ';
  571.          for i:= 1 to length(rpt_title) div 2 do
  572.          Write(lst,#8);
  573.          write(lst,rpt_title);
  574.          write(lst,unexpand);
  575.          j := i + length(rpt_title) div 2;
  576.          j := j  + (lnth div 2);
  577.        end;
  578.  
  579.  
  580.    Procedure Wrt_Address;
  581.  
  582.      var
  583.        k : integer;
  584.  
  585.      begin
  586.        addrs := '';
  587.        addrs := co_nam + ' ' + addrs + ' ' + city + ' ' + st + '  ' + zip;
  588.        if odd(length(addrs)) then addrs := addrs + ' ';
  589.        for k := 1 to lnth div 2 - (length(addrs) div 2) do
  590.          write(lst,#32);
  591.        write(lst,Emphaszd,addrs);
  592.        j := lnth div 2 + length(addrs) div 2;
  593.      end;
  594.  
  595.    Procedure Wrt_Date;
  596.      var
  597.        i : integer;
  598.      begin
  599.        for i :=  1 to lnth - (j + length(date) - 1) do
  600.          write(lst,#32);
  601.        Writeln(lst,date);
  602.      end;
  603.  
  604.    Procedure Wrt_city;
  605.      var
  606.        i : integer;
  607.      begin
  608.        city := city + ' ' + st + '  ' + zip;
  609.        k := length(city);
  610.        for i := 1 to lnth div 2  - (k div 2) do
  611.          write(lst,#32);
  612.        write(lst,city);
  613.        j := lnth div 2 + (length(city)  div 2);
  614.      end;
  615.  
  616.    Procedure Wrt_page;
  617.      var
  618.        i : integer;
  619.      begin
  620.        inc(pag_num);
  621.        str(pag_num,pag);
  622.        page := page + pag;
  623.        for i := 1 to lnth - (j + length(page)) do
  624.          write(lst,#32);
  625.        writeln(lst,page);
  626.        j := 0;
  627.      end;
  628.  
  629.      begin
  630.       page := 'Page No. ';
  631.       pag_num := 0;
  632.       lnth := 132;
  633.       write(lst,#27 + '@');
  634.       write(lst,#27 + 'P');
  635.       Title(rpt_title);
  636.       wrt_page;
  637.       Wrt_address;
  638.       Wrt_Date;
  639.       for i := 1 to lnth do
  640.         begin
  641.            write(lst,char_byte);
  642.            if (i = lnth div 2) then write(lst,'!');
  643.         end;
  644.         for i := 1 to 2 do writeln(lst);
  645.           write(lst,#27 + '<');  {Home the print head}
  646.      end;
  647.  
  648.     begin
  649.        assign(lst,'LPT1');
  650.        rewrite(lst);
  651.     end.
  652.